perm filename SUBTCH[MUS,LCS] blob
sn#007354 filedate 1974-01-08 generic text, type T, neo UTF8
C ******* SUBTCH ****** CRITICIZES MELODIC LINE.
SUBROUTINE SUBR
COMMON P(30),INUM,IPAR,CNT(27),BT,PL(48),IREST
DIMENSION N(50),JINT(50),LINT(14),INT(50),NINT(50),MINT(3)
DATA LINT/'P1','MN2','MJ2','MN3','MJ3','P4','TRT','P5','MN6',
1'MJ6','MN7','MJ7','P8','ERR'/,MINT/'UP',' ','DN'/
IAUG2='A2'
IDIM7='DM7'
C ACCEPTS UP TO 50 NOTES.
J=P(3)
IF(J.EQ.84)GO TO 1
C NOTE '84' SIGNALS END OF INPUT, NO WORK DONE UNTIL ALL NTS STORED.
I=CNT(INUM)
C 'I' WILL BE TOTAL NUMB. OF NOTES.
N(I)=J
C 'N' ARRAY STORES NOTE NUMBERS.
RETURN
1 KL=-1
NERR=0
C NERR HOLDS NUMB. OF FIRST ERROR
C WORK STARTS HERE. KL IS COUNTER FOR PAIRS OF OUTPUT.
N1=N(1)
MAJ=.FALSE.
MIN=MAJ
DO 66 K=1,I-1
66 INT(K)=N(K+1)-N(K)
DO 2 K=1,I-1
C MAIN LOOP
KM=K-2
KQ=K-1
KK=K+1
L=N(KK)-N(K)
C L IS 1/2 STEPS BETWEEN NOTES.
6 KL=KL+2
LL=IABS(L)+1
CC INT(K)=L
C LL IS INTERVAL, INT ARRAY STORES FOR FUTURE.
M=N(K)
MX=M-N1
C MX IS INTERVAL TO 1ST NOTE.
MZ=N(KK)-N1
C INT. BETWEEN NEXT NOTE AND OPENING NOTE.
IF(MX.EQ.9.OR.MX.EQ.-3)GO TO 112
C JUMP IF PERF.1,4,5,8
IF(MX.EQ.3.OR.MX.EQ.8.OR.MX.EQ.10.OR.MX.EQ.-2.
1 OR.MX.EQ.-4.OR.MX.EQ.-9)MIN=.TRUE.
C FINDS MN3 OR 6 OF SCALE
IF(MX.NE.1.AND.IABS(MX).NE.6.AND.MX.NE.-11)GO TO 60
C FINDS WRONG SCALE NOTES (FLAT 2, #4)
IF(NERR.EQ.0)NERR=K
TYPE 35,K
60 IF(MX.EQ.4.OR.MX.EQ.-8)MAJ=.TRUE.
C FINDS MJ3
IF(.NOT.MAJ.OR..NOT.MIN)GO TO 112
TYPE 36,K
IF(NERR.EQ.0)NERR=K
MIN=.FALSE.
112 IF(MX.NE.9)GO TO 50
C JUMP IF NOT MJ6,DIM7
IF(L.EQ.3)CALL BADINT(IAUG2,KK,NERR)
IF(L.EQ.-9)CALL BADINT(IDIM7,KK,NERR)
50 IF((MX.EQ.-4.AND.L.EQ.3).OR.((MX.EQ.-1.OR.MX.EQ.11).AND.L.EQ.-3))
1CALL BADINT(IAUG2,KK,NERR)
IF(MX.EQ.-1.AND.L.EQ.9)CALL BADINT(IDIM7,KK,NERR)
11 IF(LL.LT.4.OR.LL.EQ.7)GO TO 10
C WAS GO TO 200!!
IF(LL.NE.9.AND.LL.NE.13)GO TO 1100
C NEXT CHECKS DIRECTION OF OCT. OR MN6 JUMP.
IF(K.EQ.1.OR.K.EQ.I-1)GO TO 1100
IF(L*INT(K-1).LT.0)GO TO 100
TYPE 30,LINT(LL),KK
IF(NERR.EQ.0)NERR=KK
100 IF(L*INT(KK).LT.0)GO TO 1100
M=KK+1
TYPE 30,LINT(LL),M
IF(NERR.EQ.0)NERR=M
1100 IF(K.LT.3)GO TO 10
IF(N(KM).EQ.N(K).AND.IABS(INT(KQ)).GT.2)TYPE 31,K
C NON-STEP RETURN TO PITCH. NOT NECESSARILY AN ERROR.
M=IABS(N(KM)-N(K))
CC IF(M.EQ.11.OR.M.EQ.10.AND.LL.NE.13)TYPE 32,K
IF(M.NE.11.AND.M.NE.10.OR.LL.EQ.13)GO TO 10
C FINDS 7TH IN 3 NOTES.
IF(NERR.EQ.0)NERR=K
TYPE 32,K
10 M=2
IF(L.GT.0)M=1
IF(L.LT.0)M=3
NINT(K)=MINT(M)
C 'M' IS FOR UP-DOWN TYPE OUT, NINT ARRAY STORES IT.
7 IF(LL.GT.1.AND.LL.LT.13)GO TO 4
C JUMP IF INTERVAL IS PROBABLY LEGAL.
IF(LL.LT.2)CALL BADINT(LINT(LL),KK,NERR)
IF(LL.LT.14)GO TO 5
TYPE 33,KK
IF(NERR.EQ.0)NERR=KK
GO TO 5
4 IF(LL.EQ.7.OR.(LL.GT.9.AND.LL.NE.13))CALL BADINT(LINT(LL),KK,
1NERR)
C CHECKS AUG4, MJ6-MJ7
5 MM=LL
IF(MM.GT.14)MM=14
JINT(KL)=LINT(MM)
C NEXT FINDS ARPEGGIO IN 4 NOTES.
IF(K.LT.3.OR.LL.LT.4)GO TO 22
LA=IABS(N(K)-N(KM))
C INT. BETWEEN THIS AND 2ND NOTE BACK.
LB=IABS(N(KK)-N(KM))
C INT. BETWEEN NEXT NOTE AND 2ND NOTE BACK.
LC=IABS(N(KK)-N(KQ))
C INT. BETWEEN NEXT AND 1ST NOTE BACK.
2222 IF((LA.LT.3.AND.LA.GT.0).OR.(LB.LT.3.AND.LB.GT.0).OR.(LC.LT
1 .3.AND.LC.GT.0).OR.LC.EQ.11.OR.LB.EQ.11.OR.LA.EQ.11)GO TO 22
IF(IABS(INT(KM)).LT.3.OR.IABS(INT(KQ)).LT.3)GO TO 22
TYPE 37,KK
IF(NERR.EQ.0)NERR=KK
22 IF(LL.NE.2.OR.MZ.EQ.2.OR.IABS(MZ).EQ.5.OR.IABS(MZ).EQ.7
1.OR.MZ.EQ.-10)GO TO 2
C JUMP IF P4,5 OR 2ND OF SCALE OR NOT 1/2 STEP.
IF(((MZ.EQ.9.OR.MZ.EQ.11.OR.MZ.EQ.-3.OR.MZ.EQ.-1.OR.MZ.EQ.4)
1.AND.L.LT.0).OR.(
1(MZ.EQ.10.OR.MZ.EQ.12.OR.MZ.EQ.-2.OR.MZ.EQ.0).AND.L.GT.0))GO TO 2
C FINDS CHROMATICISM
IF(NERR.EQ.0)NERR=KK
TYPE 38,KK
2 JINT(KL+1)=MINT(M)
C STORES INT. NAMES AND UP-DOWN
M=N(I)
IF(N1.EQ.M.OR.N1.EQ.M+12.OR.N1.EQ.M-12)GO TO 61
TYPE 34
IF(NERR.EQ.0)NERR=I
61 TYPE 3,(JINT(L),L=1,KL+1)
TYPE 39,NERR
CALL EXIT
39 FORMAT(I3/)
3 FORMAT(3(6(3X2A4)/))
30 FORMAT(' MUST CHNG DIR WITH ',A4,' - NOTE ',I2)
31 FORMAT(' RETURNS TO SAME NOTE AFTER LEAP - NOTE ',I2)
32 FORMAT(' 7TH IN 3 NOTES - NOTE ',I2)
33 FORMAT(' SKIP TOO LARGE. NOTE ',I2)
34 FORMAT(' ENDS ON WRONG NOTE.')
35 FORMAT(' NOTE ',I2,' NOT IN SCALE.')
36 FORMAT(' NOTE ',I2,' MAJOR OR MINOR?')
37 FORMAT(' 4-NOTE ARPEGGIO - NOTE ',I2)
38 FORMAT(' CHROMATICISM - NOTE ',I2)
END
SUBROUTINE BADINT(I,J,NERR)
IF(NERR.EQ.0)NERR=J
TYPE 300,I,J
RETURN
300 FORMAT(' ILLEGAL INTERVAL, ',A4,' NOTE ',I2)
END